perm filename PGSUB.F4[PAG,LCS]7 blob sn#496812 filedate 1980-01-29 generic text, type T, neo UTF8
00100	C****  VARIOUS SUBROUTINES FOR PAGE LAYOUT PROGRAM. ****
00200	
00300		SUBROUTINE FILOUT(NAMQ,NPG)
00400		COMMON /FIN/JBAR,NPX,REND,KPX,KREAD,JEND,JSLUR,JSL2,NAMZ
00500		1,LC,LPG,MPG,CLEF,SIG,LB,SPG,MTR1,MTR2
00600		1  /SF/KL,RT,KP,STFSZ,NAMX,EXT /IVV/NUMS(1)
00700	2	FORMAT(' TYPE FILE NAME  '$)
00800	102	FORMAT(A5)
00900	103	TYPE 2
01000		CALL READX(5,NAMX,EXT,NPG,NUMS)
01100	CC103	CALL NAMEXT(EXT)
01200		IF(NAMX.NE.' ')GO TO 1
01300		EXT='TST'
01400		NAMX='AAAAA'
01500	1	NAMZ=NAMX
01600		NPG=1
01700		IF(LOOKX(NAMX,EXT).GE.0)RETURN
01800	CC	IF(LOOKX(NAMX,EXT).GE.0)GO TO 88
01900		TYPE 88,NAMX,EXT
02000		ACCEPT 102,L
02100		IF(L.EQ.'N')GO TO 103
02200	88	FORMAT(' WRITE OVER FILE ',A5,'.',A3,'????  '$)
02300		END
02400	
02500		SUBROUTINE FILEIN
02600		COMMON /FIN/JBAR,NPX,REND,KPX,KREAD,JEND,JSLUR,JSL2,NAMZ
02700		1,LC,LPG,MPG,CLEF,SIG,LB,SPG,MTR1,MTR2 /IPG/IPG,JPG,
02800		1 BRACK(0/7),RSTNUM(8),RPSZ(8),RHGT(8),RCLEF(0/7) 
02900		1 /RSP/KNM(1) /ENDL/ENDLN,N,NAME,NMPG,T /KBAR/KBAR(515)
03000		COMMON RS,JA,CLEFQ,AA,RQ(16),KQ,NQ,JQ,JJQ,KBQ,NAQ
03100		COMMON /POSI/STFF(0/7),JJ2,JPQ /LLL/L,LL,I,RXQ
03200		COMMON/STF/RSTFAC(0/7),RSTJ2 /PX/KPN(1) /Q/Q(1)
03300		1 /NBAR/NBAR(1)
03400		EQUIVALENCE (LASTNM,KBAR(3))
03500	
03600	CCC	IF(NMPG.EQ.'PAGEA')NPZ='PAGEZ'
03700		IF(NBAR(LC).EQ.0)CALL EXIT
03800		IF(KPX.EQ.1)GO TO 104
03900	C  SKIP THIS FIRST TIME.  IT SHUFFLES DATA FORWARD IN ARRAY.
04000		J=KPX-1
04100		JJ=KPN(KPX)-1
04200		DO 105 K=1,NPX-J
04300	105	KPN(K)=KPN(K+J)-JJ
04400		J=KPN(NPX)-JJ
04500	C  HOW MUCH TO SHIFT THE Q ARRAY
04600	CX	DO 106 K=1,J
04700	CX106	Q(K)=Q(K+JJ)
04800		CALL RLOOP(Q,Q(JJ+1),J)
04900		KPX =NPX-KPX+1
05000	C  UPDATE POINTERS FOR NEXT READIN
05100		KQ=KPN(KPX)
05200		JPX=KQ-1
05300	
05400	104	KL=1
05500		KP=1
05600		JEND=0
05700	C  FLAG FOR PAGE END - WHEN -1
05800		IF(LB.LT.NBAR(LC))GO TO 220
05900		NPX=KPX
06000		KPX=1
06100		LB=0
06200		GO TO 241
06300	220	CALL GETEXT(NMPG,'PAG')
06400		CALL EXTIN(RSTFAC,22)
06500	211	CALL EXTIN(KPN(KPX),JJ2)
06600		CALL EXTIN(Q(KQ),JPQ)
06700		JP=JJ2+KPX
06800		IF(JP.LE.450)GO TO 1211
06900		TYPE 3211,JP
07000		STOP
07100	3211	FORMAT(' ARRAY OVERLOAD. KPN=',I3,'/450')
07200	4211	FORMAT(' ARRAY OVERLOAD. Q=',I4,'/4500')
07300	1211	JP=KQ+JPQ
07400		IF(JP.LE.4500)GO TO 2211
07500		TYPE 4211,JP
07600		STOP
07700	2211	IF(KPX.EQ.1)GO TO 140
07800	CC	IF(KPX.EQ.LPX)GO TO 311
07900	C  AVOIDS DOUBLE METERS, I HOPE!
08000	CC	IF(Q(KQ+1).NE.18)GO TO 311
08100	C LOOK AT FIRST NEW ITEM, IS IT A METER?
08200	CC	KPX=LPX
08300	CC	KQ=KPN(KPX)
08400	C YES, GO BACK AND READ OVER OLD METERS.
08500	CC	JPX=KQ-1
08600	CC	GO TO 220
08700	311	OLD=Q(KPN(KPX-1)+3)
08800		B=0
08900		JJ=JJ2+KPX-1
09000		DO 420 JP=KPX,JJ
09100		K=KPN(JP)+JPX
09200		KPN(JP)=K
09300		R=Q(K+1)
09400		IF(B.NE.0)GO TO 420
09500		IF(R.LE.2)GO TO 620
09600		IF(R.NE.18)GO TO 420
09700	CHECK UP ON METER DUPLICATE.
09800		DO 720 KK=KPX-1,1,-1
09900		R=CODEN(KPN,KK,Q,LA)
10000	720	IF(R.NE.18)GO TO 820
10100		GO TO 420
10200	820	IF(KK.EQ.KPX-1)GO TO 420
10300		KPX=KK+1
10400		KQ=KPN(KPX)
10500		JPX=KQ-1
10600	C GO BACK AND READ OVER DANGLING METER
10700		GO TO 220
10800	620	B=Q(K+3)
10900	C B=POS OF FIRST NOTE OR REST IN NEW FILE.
11000		DO 1 KK=KPX,JP
11100		R=CODEN(KPN,KK,Q,LA)
11200		IF(R.NE.44)GO TO 7
11300		IF(Q(LA+6).EQ.0.OR.Q(LA).LT.4)GO TO 1
11400	C LOOK AT LINES, CRESC, DASHES, WIGGLES ONLY.
11500		GO TO 2
11600	7	IF(R.NE.7)GO TO 5
11700		IF(Q(LA).LT.5)GO TO 1
11800		RR=ABS(Q(LA+7))
11900		IF(RR.GT.1.AND.RR.LT.8)GO TO 1
12000	C AVOID PEDAL MARKS.
12100		GO TO 2
12200	5	IF(R.NE.5)GO TO 1
12300	C FOUND SLUR INTO LEFT SIDE OF LINE
12400		IF(Q(LA+3))Q(LA+3)=B-5
12500		A=Q(LA+6)
12600		C=Q(LA+2)
12700	2	DO 3 NN=1,KPX-1
12800		RR=CODEN(KPN,NN,Q,II)
12900		IF(RR.NE.R)GO TO 3
13000		IF(Q(II).LT.4)GO TO 3
13100		IF(Q(II+3).GT.D)GO TO 3
13200		IF(Q(II+2).NE.C)GO TO 3
13300	C CATCHES ONLY ONE SLUR(ETC.) POS PER STAFF!!
13400		IF(Q(II+6).LT.D)GO TO 3
13500		Q(II+6)=A
13600	C  ADJUSTS PARAM 6 TO POSITION IN NEW FILE.
13700		GO TO 1
13800	3	CONTINUE
13900	1	CONTINUE
14000	420	CONTINUE
14100	140	JPX=KQ+JPQ-3
14200	C  NUM OF WORDS TO SHIFT.
14300		LPX=KPX
14400	C  SO IT WON'T GET CONFUSED
14500	41	NMPG=NMPG+2
14600	C  NMPG = NAME OF INPUT FILES
14700		IF(NMPG.EQ.'PAGEZ'+2)NMPG='PAGFA'
14800	C  WILL GO FROM PAGEA TO PAGFZ, ETC. (104)  ADD TO THIS IF NEEDED.
14900		IF(NMPG.EQ.'PAGFZ'+2)NMPG='PAGGA'
15000		IF(NMPG.EQ.'PAGGZ'+2)NMPG='PAGHA'
15100	CCC	IF(NMPG.LE.NPZ)GO TO 2242
15200	CCC	NPZ=NPZ+256
15300	CCC	NMPG='PAGFA'
15400	CC	L=JJ2-2
15500	CC	NPX=KPX+L
15600	2242	NPX=KPX+JJ2-2
15700	241	JBAR=NBAR(LC)
15800	
15900		DO 20 JP=KPX,NPX-1
16000		R=CODEN(KPN,JP,Q,N)
16100	CC	N=KPN(JP)   	R=Q(N+1)
16200		IF(R.NE.4)GO TO 20
16300	C  FINDS BAR LINES IN THIS PART OF DATA
16400		LB=LB+1
16500		IF(LB.NE.JBAR)GO TO 20
16600		KPX=JP+1
16700		D=Q(N+3)
16800			DO 121 L=JP-1,1,-1
16900			R=CODEN(KPN,L,Q,N)
17000			IF(R.NE.5)GO TO 121
17100			RR=Q(N+6)
17200			IF(RR.LT.D)GO TO 121
17300			Q(N+6)=-1
17400			C=Q(N+2)
17500			B=0
17600				DO 221 KK=JP+1,NPX-1
17700				R=CODEN(KPN,KK,Q,NN)
17800				IF(R.NE.1)GO TO 221
17900				IF(Q(NN+2).NE.C)GO TO 221
18000	C		  CHECK ON STAFF NUM.
18100				A=Q(NN+3)-1
18200				IF(RR.LT.A)GO TO 221
18300				B=B-1
18400				IF(ABS(RR-A).LE.2)GO TO 321
18500	C		IF IT'S CLOSE ENOUGH CALL IT EQUAL.
18600	221			CONTINUE
18700	321		IF(B)Q(N+6)=B
18800	121		CONTINUE
18900	C  SAVE POS OF LAST BAR FOR SLUR CONNECTIONS, ETC.
19000	CC	LPX=KPX
19100	C  SAVE POINTER IN CASE OF DOUBLE METERS.
19200	20	CONTINUE
19300		IF(LB.GE.JBAR)GO TO 520
19400		KPX=NPX
19500		KQ=JPX+1
19600		GO TO 220
19700	520	KQ=Q(KPN(KPX)+1)
19800	CIRC	IF(KQ.NE.18.AND.KQ.NE.44)GO TO 120
19900		IF(KQ.NE.18.AND.KQ.NE.44.AND.KQ.NE.3)GO TO 120
20000	CC520	IF(Q(KPN(KPX)+1).NE.18)GO TO 120
20100	C LOOKS FOR CLEF, METER OR SECONDARY BAR LINES(44) BEYOND LAST BAR IN LINE.
20200		IF(KPX.GE.NPX)GO TO 10
20300		KPX=KPX+1
20400		GO TO 520
20500	120	IF(NPX.LE.KPX)GO TO 10
20600		KK=KPX-1
20700		R=Q(KPN(KK)+3)+.5
20800		DO 11 K=KK,NPX
20900		IF(Q(KPN(K)+3).GT.R)GO TO 12
21000	11	KPX=K
21100	C ABOVE CATCHES THINGS IN SAME POS. AS LAST BAR LINE.
21200	12	IF(KPX.LT.NPX)KPX=KPX+1
21300	10	KQ=KPN(KPX)
21400		LB=LB-JBAR
21500		L=KPX-1
21600	C L=TOTAL ITEMS FOR THIS LINE. JBAR=TOTAL BARS, LB=HOW MANY LEFT OVER
21700		I=L
21800		IF(LB.NE.0)RETURN
21900		KPX=1
22000		KQ=1
22100		END
22200	
22300		SUBROUTINE STAVES
22400		COMMON /FIN/JBAR,NPX,REND,KPX,KREAD,JEND,JSLUR,JSL2,NAMZ
22500		1,LC,LPG,MPG,CLEF,SIG,LB,SPG,MTR1,MTR2/RSIG/RSIG(0/7)
22600		COMMON /SF/KL,RT,KP,STFSZ,NAMX /IPG/IPG,JPG,BRACK(0/7),
22700		1 RSTNUM(8),RPSZ(8),RHGT(8),RCLEF(0/7) 
22800		1 /RSP/KNM(1) /ENDL/ENDLN,N,NAME,NMPG,T /KBAR/KBAR(515)
22900		COMMON RS,JA,CLEFQ,AA,RQ(16),KQ,NQ,JQ,JJQ,KBQ,NAQ
23000		1 /STF/RSTFAC(0/7),RSTJ2 /IVV/OSLUR(1)
23100		COMMON /POSI/STFF(0/7),JJ2,JPQ /LLL/L,LL,I,RXQ
23200		1/PX/KPN(1) /Q/Q(1) /PTR/KWDS(1) /XRN/RN(1) /NBAR/NBAR(1)
23300		DIMENSION ENDSTF(450),STFNM(0/7)
23400	C  ENDSTF AND ENDPTR FOR CARRYING STUFF FROM ONE LINE TO THE NEXT.
23500		EQUIVALENCE (RQ(2),R4),(R5,RQ(3)),(R6,RQ(4)),(R7,RQ(5))
23600	 	1,(ENDSTF,KBAR(4))
23700		1,(R8,RQ(6)),(R9,RQ(7)),(STFNM,KBAR(508))
23800		DATA SLSP/12.0/
23900		IF(LC.EQ.1)RA=0
24000	C RA IS LEFT POS OF Q DATA. (IT SHIFTS AS LC CHANGES.)
24100		KL=1
24200		KP=1
24300		LC=LC+1
24400	335	RX=0
24500		IF(NBAR(LC).EQ.0)JEND=-1
24600	3	JJ=KP
24700	
24800	C ******** PUTS IN STAFF ********
24900		RS=3.
25000	C  RS IS WDCNT FOR SUBR. STAFF
25100		IF(RT.EQ.0)RS=6
25200	C =6 FOR BOTTOM STAFF.  PUTS IN SPACER.
25300	CC331	IF(IPG)GO TO 411
25400		HX=8
25500		G=0
25600		RX=RT
25700		DO 611 JP=1,LPG
25800		RT=RSTNUM(JP)
25900		LA=RT
26000		RS=3
26100	C WD CNT IS RS, HX IS CODE(8), ARRAYS AND LPG(JPG) WERE SET UP IN MAIN.
26200		RR=0
26300		IF(NAMX.EQ.NAMZ)GO TO 11
26400		IF(RT.NE.0)GO TO 11
26500		RS=6
26600		RR=SPG
26700	C  FOR SPACER ON STAFF 0
26800	11	IF(STFNM(LA).NE.0)RS=7
26900	611	CALL STAFF(RS,HX,G,RHGT(JP),RPSZ(JP),G,G,RR,STFNM(LA),G,G,G)
27000	C  STFNM IS INST. NAME IN P9 OF STAFF PARAMS.
27100		HX=LPG
27200		IF(IPG)GO TO 6
27300		RS=4.
27400		RT=0
27500		CALL STAFF(2.,RS,G,HX,G,G,G,G,G,G,G,G)
27600		DO 1611 JP=1,LPG
27700		RT=RSTNUM(JP)
27800		LA=RT
27900		BR=BRACK(LA)
28000		IF(BR.EQ.0)GO TO 1611
28100	    	R7=AMOD(BR,100.)
28200		R4=(BR-R7)/100.
28300		CALL STAFF(5.,RS,G,R4,G,G,R7,G,G,G,G,G)
28400	1611	CONTINUE
28500		RT=RX
28600	CC	GO TO 511
28700	CC411	CALL STAFF(RS,8.,0,HGT,RSTJ2,0,0,SP,SP,SP,SP,SP)
28800	CC	HGT=HGT-HX
28900	CI511	IF(JEND)GO TO 60
29000	C FOR PREMATURE PAGE END
29100	CP	IF(K.NE.I)GO TO 6
29200	CI	IF(RT.EQ.0)GO TO 6
29300	CI60	IF(IPG.EQ.0)GO TO 6
29400	CI	RX=RT
29500	CI	RT=0
29600	CI	CALL STAFF(6.,8.,0,0,0,0,1.,SP,SP,SP,SP,SP)
29700	C  PUTS IN SPACER
29800	CI	RT=RX
29900	
30000	C  ****** NEXT FOR CLEFS ************
30100	6	RX=1
30200		IF(CLEF.EQ.-99)GO TO 33
30300	C  ONLY STAFF FOR FIRST LINE AT TOP.
30400		RX=8.*RSTJ2
30500	C  THE SPACER
30600	CC	LA=0
30700	CC	IF(IPG)GO TO 3011
30800		LA=LPG
30900	3111	RT=RSTNUM(LA)
31000		LL=RT
31100		CLEF=RCLEF(LL)
31200	C GETS CLEF FOR PAGE LAYOUT, RT IS STAFF# IN CALL
31300		LA=LA-1
31400	3011	IF(CLEF.NE.99)CALL STAFF(3.,3.,1.5,0,CLEF,0,0,0,0,0,0,0)
31500		IF(SIG.EQ.-99)GO TO 3211
31600	C  ***** NEXT FOR KEY SIG. ********
31700		RS=4.
31800		R5=RSIG(LL)
31900	332	IF(R5.NE.99)CALL STAFF(RS,17.,10.*RSTJ2,0,R5,CLEF,0,0,0,0,0,0)
32000	3211	IF(LA.GT.0)GO TO 3111
32100		RX=11.*RSTJ2
32200	C  RX SETS POS OF NEXT ITEM ON STAFF
32300		R7=RX
32400	
32500	33	LA=1
32600		KX=0
32700	61	IF(ENDSTF(LA).EQ.0)GO TO 31
32800	C  JUMP IF NO CARRYOVERS FROM PREVIOUS LINE.
32900		R5=ENDSTF(LA+1)
33000		IF(R5.NE.18)GO TO 261
33100	CHECK UP ON METER FROM PREV. LINE.  AVOID DUPLICATE.
33200		DO 361 KK=1,I
33300		R=CODEN(KPN,KK,Q,LL)
33400		IF(R.EQ.4)GO TO 261
33500	C JUMP IF METER FOUND BEFORE 1ST BAR LINE.
33600	361	IF(R.EQ.18)GO TO 161
33700	261	RT=ENDSTF(LA+2)
33800		IF(R5.NE.18)GO TO 461
33900		IF(KX)GO TO 461
34000		KX=-1
34100		RX=RX+4
34200		IF(ENDSTF(LA).GT.4)RX=RX+5
34300	461	CALL STAFF(ENDSTF(LA),ENDSTF(LA+1),ENDSTF(LA+3),ENDSTF(LA+4),
34400		1 ENDSTF(LA+5),ENDSTF(LA+6),ENDSTF(LA+7),ENDSTF(LA+8),
34500		1 ENDSTF(LA+9),ENDSTF(LA+10),ENDSTF(LA+11),ENDSTF(LA+12))
34600	161	LA=LA+13
34700		GO TO 61
34800	
34900	C  RX SPACES NEXT ITEM TO RIGHT OF LINE BEGINNING.
35000	31	R4=Q(KPN(I)+3)
35100	C GET POS OF LAST ITEM FOR THIS LINE
35200		DO 32 K=1,I
35300	32	IF(Q(KPN(K)+3).LT.R4)R4=Q(KPN(K)+3)
35400	C ALL THIS NEEDED BECAUSE OF GRACE NOTE AT START OF LINE PROBLEM.
35500	
35600		IF(RA.LT.R4)RA=R4
35700		R4=RA-.1
35800	C  -.1  FOR ROUND-OFF ERRORS
35900		LA=I
36000		DO 831 K=1,I
36100		KK=KPN(K)+3
36200	C FIND SLURS ETC. BEFORE 1ST NOTES OR REST. (NOT NEG.)
36300		IF(Q(KK).GE.RA)GO TO 231
36400	831	Q(KK)=0
36500	231	RA=CODEN(KPN,LA,Q,K4)
36600		IF(RA.EQ.4)GO TO 131
36700		IF(RA.NE.44)GO TO 931
36800		IF(Q(K4).LE.2)GO TO 131
36900	CATCHES BAR LINES ON UPPER STAVES.
37000	931	LA=LA-1
37100		GO TO 231
37200	131	RA=Q(K4+3)
37300		R5=RA+.001
37400	C +.001 IS TO CATCH SLIGHT ROUNDOFF ERRORS WHEN CODE 44 IS LAST ITEM.
37500		DO 731 K=1,I
37600	CC	KK=KPN(K)  	R=Q(KK+1)
37700		R=CODEN(KPN,K,Q,KK)
37800		IF(R.EQ.44)GO TO 631
37900		IF(R.EQ.7)GO TO 631
38000		IF(R.NE.5)GO TO 731
38100	631	IF(Q(KK).LT.4)GO TO 731
38200		R=Q(KK+6)
38300		IF(R.LT.R5)GO TO 731
38400	C R5 = LEFT SIDE OF ITEM NOW, R= RIGHT SIDE.
38500		Q(KK+6)=R5
38600	C  CATCHES RIGHT SIDE OF THINGS FOR MOVER. (PEDS?)
38700	731	CONTINUE
38800		RS=-1
38900	C  -1 SO ALL STAVES WILL MOVE AT ONCE.
39000	CC	RS=0
39100		R7=0
39200	C R7=0 FOR GETPTS TO LOOK AT ALL STAVES.
39300		R8=RX
39400		R9=200.
39500		LL=0
39600		L=I
39700		CALL PTMOVE(Q,KPN)
39800		IF(LA.EQ.I)RETURN
39900	C NEXT PUTS METER JUST BEYOND END OF LINE
40000		R=202
40100		R7=Q(KPN(LA+1)+3)
40200	C  R7 HOLDS STAFF NUM. FOR THINGS BEYOND END OF LINE.
40300		DO 531 K5=LA+1,I
40400		K7=KPN(K5)
40500		K4=0
40600		IF(Q(K7+1).EQ.18)K4=Q(K7+5)*100+Q(K7+6)
40700	C  K4 STORES METER (TOP*100+BOTTOM)
40800		IF(Q(K7+3).EQ.R7)GO TO 531
40900		R7=Q(K7+3)
41000	C THIS PROBABLY WON'T ALWAYS DO THE RIGHT THING!!
41100		R=R+5
41200	CM	IF(MTR1.GT.0.AND.K4.NE.0)MTR2=K4
41300	531	Q(K7+3)=R
41400	CM431	Q(K7+3)=R
41500	CM531	IF(K4.NE.0.AND.MTR1)MTR1=K4
41600		END
41700